home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / canvas.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  5.9 KB  |  193 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test out the procedures in tkCanvas.c,
  2. # which implements generic code for canvases.  It is organized in the
  3. # standard fashion for Tcl tests.
  4. #
  5. # Copyright (c) 1995-1996 Sun Microsystems, Inc.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10. # SCCS: @(#) canvas.test 1.10 97/07/31 10:22:48
  11.  
  12. if {[info procs test] != "test"} {
  13.     source defs
  14. }
  15.  
  16. foreach i [winfo children .] {
  17.     destroy $i
  18. }
  19. wm geometry . {}
  20. raise .
  21.  
  22. # XXX - This test file is woefully incomplete.  At present, only a
  23. # few of the features are tested.
  24.  
  25. canvas .c
  26. pack .c
  27. update
  28. set i 1
  29. foreach test {
  30.     {-background #ff0000 #ff0000 non-existent
  31.         {unknown color name "non-existent"}}
  32.     {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
  33.     {-bd 4 4 badValue {bad screen distance "badValue"}}
  34.     {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  35.     {-closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}}
  36.     {-confine true 1 silly {expected boolean value but got "silly"}}
  37.     {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
  38.     {-height 2.1 2 x42 {bad screen distance "x42"}}
  39.     {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
  40.     {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}
  41.     {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}
  42.     {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}}
  43.     {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
  44.     {-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
  45.     {-insertontime 100 100 3.2 {expected integer but got "3.2"}}
  46.     {-insertwidth 1.3 1 6x {bad screen distance "6x"}}
  47.     {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
  48.     {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
  49.     {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  50.     {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
  51.     {-takefocus "any string" "any string" {} {}}
  52.     {-width 402 402 xyz {bad screen distance "xyz"}}
  53.     {-xscrollcommand {Some command} {Some command} {} {}}
  54.     {-yscrollcommand {Another command} {Another command} {} {}}
  55. } {
  56.     set name [lindex $test 0]
  57.     test canvas-1.$i {configuration options} {
  58.     .c configure $name [lindex $test 1]
  59.     lindex [.c configure $name] 4
  60.     } [lindex $test 2]
  61.     incr i
  62.     if {[lindex $test 3] != ""} {
  63.     test canvas-1.$i {configuration options} {
  64.         list [catch {.c configure $name [lindex $test 3]} msg] $msg
  65.     } [list 1 [lindex $test 4]]
  66.     }
  67.     .c configure $name [lindex [.c configure $name] 3]
  68.     incr i
  69. }
  70.  
  71.  
  72. catch {destroy .c}
  73. canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
  74.     -highlightthickness 0
  75. pack .c
  76. update
  77. test canvas-2.1 {CanvasWidgetCmd, xview option} {
  78.     .c configure -xscrollincrement 40 -yscrollincrement 5
  79.     .c xview moveto 0
  80.     update
  81.     set x [list [.c xview]]
  82.     .c xview scroll 2 units
  83.     update
  84.     lappend x [.c xview]
  85. } {{0 0.3} {0.4 0.7}}
  86. test canvas-2.2 {CanvasWidgetCmd, xview option} {nonPortable} {
  87.     # This test gives slightly different results on platforms such
  88.     # as NetBSD.  I don't know why...
  89.     .c configure -xscrollincrement 0 -yscrollincrement 5
  90.     .c xview moveto 0.6
  91.     update
  92.     set x [list [.c xview]]
  93.     .c xview scroll 2 units
  94.     update
  95.     lappend x [.c xview]
  96. } {{0.6 0.9} {0.66 0.96}}
  97.  
  98. catch {destroy .c}
  99. canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \
  100.     -borderwidth 0 -highlightthickness 0
  101. pack .c
  102. update
  103. test canvas-3.1 {CanvasWidgetCmd, yview option} {
  104.     .c configure -xscrollincrement 40 -yscrollincrement 5
  105.     .c yview moveto 0
  106.     update
  107.     set x [list [.c yview]]
  108.     .c yview scroll 3 units
  109.     update
  110.     lappend x [.c yview]
  111. } {{0 0.5} {0.1875 0.6875}}
  112. test canvas-3.2 {CanvasWidgetCmd, yview option} {
  113.     .c configure -xscrollincrement 40 -yscrollincrement 0
  114.     .c yview moveto 0
  115.     update
  116.     set x [list [.c yview]]
  117.     .c yview scroll 2 units
  118.     update
  119.     lappend x [.c yview]
  120. } {{0 0.5} {0.1 0.6}}
  121.  
  122. test canvas-4.1 {ButtonEventProc procedure} {
  123.     eval destroy [winfo children .]
  124.     canvas .c1 -bg #543210
  125.     rename .c1 .c2
  126.     set x {}
  127.     lappend x [winfo children .]
  128.     lappend x [.c2 cget -bg]
  129.     destroy .c1
  130.     lappend x [info command .c*] [winfo children .]
  131. } {.c1 #543210 {} {}}
  132.  
  133. test canvas-5.1 {ButtonCmdDeletedProc procedure} {
  134.     eval destroy [winfo children .]
  135.     canvas .c1
  136.     rename .c1 {}
  137.     list [info command .c*] [winfo children .]
  138. } {{} {}}
  139.  
  140. catch {destroy .c}
  141. canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
  142.     -borderwidth 2 -highlightthickness 3
  143. pack .c
  144. update
  145. test canvas-6.1 {CanvasSetOrigin procedure} {
  146.     .c configure -xscrollincrement 0 -yscrollincrement 0
  147.     .c xview moveto 0
  148.     .c yview moveto 0
  149.     update
  150.     list [.c canvasx 0] [.c canvasy 0]
  151. } {-205.0 -105.0}
  152. test canvas-6.2 {CanvasSetOrigin procedure} {
  153.     .c configure -xscrollincrement 20 -yscrollincrement 10
  154.     set x ""
  155.     foreach i {.08 .10 .48 .50} {
  156.     .c xview moveto $i
  157.     update
  158.     lappend x [.c canvasx 0]
  159.     }
  160.     set x
  161. } {-165.0 -145.0 35.0 55.0}
  162. test canvas-6.3 {CanvasSetOrigin procedure} {
  163.     .c configure -xscrollincrement 20 -yscrollincrement 10
  164.     set x ""
  165.     foreach i {.06 .08 .70 .72} {
  166.     .c yview moveto $i
  167.     update
  168.     lappend x [.c canvasy 0]
  169.     }
  170.     set x
  171. } {-95.0 -85.0 35.0 45.0}
  172. test canvas-6.4 {CanvasSetOrigin procedure} {
  173.     .c configure -xscrollincrement 20 -yscrollincrement 10
  174.     .c xview moveto 1.0
  175.     .c canvasx 0
  176. } {215.0}
  177. test canvas-6.5 {CanvasSetOrigin procedure} {
  178.     .c configure -xscrollincrement 20 -yscrollincrement 10
  179.     .c yview moveto 1.0
  180.     .c canvasy 0
  181. } {55.0}
  182.  
  183. set l [interp hidden]
  184. eval destroy [winfo children .]
  185.  
  186. test canvas-7.1 {canvas widget vs hidden commands} {
  187.     catch {destroy .c}
  188.     canvas .c
  189.     interp hide {} .c
  190.     destroy .c
  191.     list [winfo children .] [interp hidden]
  192. } [list {} $l]
  193.